Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue30/expreval/EXPREVAL.ZIP/Expressions.pas

Pascal/Delphi Source File | 1998-01-02 | 61.4 KB | 2,136 lines

unit Expressions;
interface
{main documentation block just before implementation.

This unit written by Martin Lafferty of Production Robots Engineering Ltd
18/6/97

If you have any questions/comments I would be pleased to hear from you.

If you discover any bugs in this software I would be VERY pleased to
hear from you.

If you want to offer me work implementing extensions or applications using this
software then I will be moderately pleased to hear from you (if I am busy) or
VERY VERY pleased to hear from you (if I am not)

in any event, my address is:   [e-mail]

I have found this code very useful and surprisingly robust. I sincerely hope you do too.


This code developed with Delphi 3.0, but I can't offhand think of any reason why it wouldn't
work with Delphi 2.0. I have a 16 bit (Delphi 1.0) version somewhere: email me if you are
interested in that and I will dig it out. It is not well documented though.
}

uses
  Classes,
  SysUtils;

type
  TExprType = (ttString, ttFloat, ttInteger, ttBoolean);

  TExpression =
  class
  private
  protected
    function GetAsString: String; virtual;
    function GetAsFloat: Double; virtual;
    function GetAsInteger: Integer; virtual;
    function GetAsBoolean: Boolean; virtual;
    function GetExprType: TExprType; virtual; abstract;
  public
    property AsString: String read GetAsString;
    property AsFloat: Double read GetAsFloat;
    property AsInteger: Integer read GetAsInteger;
    property AsBoolean: Boolean read GetAsBoolean;
    property ExprType: TExprType read GetExprType;
    function CanReadAs(aExprType: TExprType): Boolean;
      {means 'can be interpreted as'. Sort of}
    constructor Create;
    destructor Destroy; override;
  end;

  TStringLiteral =
  class(TExpression)
  private
    FAsString: String;
  protected
    function GetAsString: String; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aAsString: String);
  end;

  TFloatLiteral =
  class(TExpression)
  private
    FAsFloat: Double;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aAsFloat: Double);
  end;

  TIntegerLiteral =
  class(TExpression)
  private
    FAsInteger: Integer;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aAsInteger: Integer);
  end;

  TBooleanLiteral =
  class(TExpression)
  private
    FAsBoolean: Boolean;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetAsBoolean: Boolean; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aAsBoolean: Boolean);
  end;

  TParameterList =
  class(TList)
  private
    function GetAsString(i: Integer): String;
    function GetAsFloat(i: Integer): Double;
    function GetAsInteger(i: Integer): Integer;
    function GetAsBoolean(i: Integer): Boolean;
    function GetExprType(i: Integer): TExprType;
    function GetParam(i: Integer): TExpression;
  public
    destructor Destroy; override;
    property Param[i: Integer]: TExpression read GetParam;
    property ExprType[i: Integer]: TExprType read GetExprType;
    property AsString[i: Integer]: String read GetAsString;
    property AsFloat[i: Integer]: Double read GetAsFloat;
    property AsInteger[i: Integer]: Integer read GetAsInteger;
    property AsBoolean[i: Integer]: Boolean read GetAsBoolean;
  end;

  TFunction =
  class(TExpression)
  private
    FParameterList: TParameterList;
    function GetParam(n: Integer): TExpression;
  public
    constructor Create( aParameterList: TParameterList);
    destructor Destroy; override;
    function ParameterCount: Integer;
    property Param[n: Integer]: TExpression read GetParam;
  end;

  EExpression = class(Exception);

  TIdentifierFunction = function( const Identifier: String;
                                  ParameterList: TParameterList): TExpression of Object;

function CreateExpression( const S: String;
                IdentifierFunction: TIdentifierFunction): TExpression;
const
  MaxStringLength = 255; {why?}

  {to get a string representation of TExprType use NExprType[ExprType] }
  NExprType: array[TExprType] of String =
      ('String', 'Float', 'Integer', 'Boolean');



{for debugging version, checking memory leaks}
var
  InstanceCount: Integer = 0;

{This unit comprises a mixed type expression evaluator which follows pascal
syntax (reasonably accurately) and approximates standard pascal types.

Delphi already implements more than one mechanism for providing type flexibility - variants
are the most notable of these. It may have been rational to implement this unit using Variants,
but I have chosen not to do so. Instead, I use an a approach which is (vaguely) analogous to
the approach used by TField and its descendents.

The Basics
----------
The class defined above, TExpression, represents an expression in the most general sense. It
has a type and a Value. The key properties of TExpression are:

    property AsString: String;
    property AsFloat: Double;
    property AsInteger: Integer;
    property AsBoolean: Boolean;
    property ExprType: TExprType;

note
    TExprType = (ttString, ttFloat, ttInteger, ttBoolean);

Not all of these properties will yield a valid result, but more than one of them might. This
sounds a little confusing, but isn't. Consider an expression in which ExprType = ttString and
AsString = 'This is a string'. In this case, AsFloat, AsInteger, AsBoolean are all invalid, and
any attempt to reference them will raise an exception (of type EExpression). On the other hand,
an expression where ExprType = ttBoolean and AsBoolean = TRUE, will yield valid results for all
of AsInteger (1), AsFloat (1.0), AsString ('TRUE'). These are called (my nomenclature) 'implicit
upcasts'. By comparison to Pascal, Type checking is quite liberal and these 'upcasts' will always
be made if required by the syntax of the expression. The four supported types are graded
according to their 'generality'. By this reckoning ttString > ttFloat > ttInteger > ttBoolean.
A more 'specific' type will always be cast to a more 'general' type if necessary. Typecasts
can also be forced using Pascal Syntax (e.g. String(10) = '10'), but are seldom necessary.

In contrast 'downcasts' ie from a general type to a more specific will never be made implicitly
and cannot be forced. For example, a ttString can never be cast into ttFloat even if the string
forms a valid floating number, say '3.142'. Support for downcasts could be added to this unit
and may be useful, but for now these casts will fail.


The basic mechanism for creating expressions is the function

function CreateExpression( const S: String;
                IdentifierFunction: TIdentifierFunction): TExpression;

Perhaps unsurprisingly, CreateExpression creates an object of type TExpression (or a descendent).
The properties of this object give the value of the expression.

Parameters
  S: String
  This constains the string you wish to parse. This string is the expression you wish to
  evaluate, as you would enter it into your code or into the 'Evalute/Modify' dialog box.

  arbitrary examples:

  4*5 + 2
  (pi/3 + 2.5) < 5.78
  410 div Pos('st', 'this is a string')

  IdentifierFunction:
  This is a function which you may provide if you wish to support additional indentifiers
  in addition to the standard functions and operators. If your expressions contain only
  literals, operators and standard functions, you may pass NIL as an identifier function.

If you create an expression using CreateExpression you must remember to dispose of it. Use
TExpression.Free for this purpose.

Example 1
---------

procedure TForm1.EG1ButtonClick(Sender: TObject);
var
  s: String;
  E: TExpression;
begin
  s:= '';
  if InputQuery('Tester', 'Enter an expression...', s) then
  begin
    E:= CreateExpression(s, nil);
    if Assigned(E) then
    try
      MessageDlg(
        Format('E.AsString = %s E.ExprType = %s',
               [E.AsString, NExprType[E.ExprType]]),
        mtInformation, [mbOK], 0)
    finally
      E.Free
    end
  end
end;

This code is implemented in the 'Tester' project distributed with this file, and attached to
TestForm.EG1Button.


Standard Operators
------------------
The best reference source for the operators / functions supported by this
unit is the Borland Pascal 7.0 Language Guide - Ch6 'Expressions'. This is
possibly the most recent piece of clear, comprehensive documentation issued
by Borland. What follows is summarised from this excellent source material.

The following operators are supported:

Binary Arithmetic Operators
Operator   Operation          Operand Types         Result Type
--------   ---------          -------------         -----------
+          addition           Integer               Integer
                              Float                 Float
-          subtraction        Integer               Integer
                              Float                 Float
*          multiplication     Integer               Integer
                              Float                 Float
/          division           Integer               Float
                              Float                 Float
div        integer division   Integer               Integer
mod        modulo             Integer               Integer

Unary Arithmetic Operators
Operator   Operation          Operand Type          Result Type
--------   ---------          ------------          -----------
+          sign identity      Integer               Integer
                              Float                 Float
-          sign negation      Integer               Integer
                              Float                 Float

Logical (BITWISE) Operators
(NB table 6.4 of BP Language guide contains errors)
Operator   Operation          Operand Type(s)       Result Type
--------   ---------          ---------------       -----------
not        bitwise negation   Integer               Integer
and        bitwise and        Integer               Integer
or         bitwise or         Integer               Integer
xor        bitwise xor        Integer               Integer
shl        shift left         Integer               Integer
shr        shift right        Integer               Integer

Boolean Operators
Operator   Operation          Operand Type(s)       Result Type
--------   ---------          ---------------       -----------
not        negation           Boolean               Boolean
and        logical and        Boolean               Boolean
or         logical or         Boolean               Boolean
xor        logical xor        Boolean               Boolean

String Operator
Operator   Operation          Operand Types         Result Type
--------   ---------          -------------         -----------
+          concatenation      String                String

Relational Operators
Operator Type  Operation      Operand Types         Result Type
-------------  ---------      -------------         -----------
=              equal          Compatible pair       Boolean
<>             not equal      Compatible pair       Boolean
<              less than      Compatible pair       Boolean
>              greater than   Compatible pair       Boolean
<=             less than or   Compatible pair       Boolean
               equal to
>=             greater than   Compatible pair       Boolean
               or equal to

Note that this unit does not support Set Types or their operators

Standard Functions
------------------
The following Standard functions are supported. For a full description of
these functions and their parameters refer to Delphi or BP on-line help.

Arithmetic functions
 TRUNC, ROUND, ABS, ARCTAN, COS, EXP, FRAC, INT, LN, PI, SIN, SQR, SQRT


String Functions
  UPPER, LOWER, COPY, POS, LENGTH

in addition to the RTL functions, the following specials are supported:

 function Power(Base, Exponent: Float): Float;

This unit also supports a form of the 'C' construct known as 'Conditional Expression',
also found in many spreadsheets. This is the IF expression

IF(Condition, TrueResult, FalseResult)

Condition is a Boolean expression. When the function is evaluated,
it returns TrueResult if Condition else FalseResult. TrueResult and FalseResult
need not be of the same type and the type of the IF expression may change depending
on Condition. For this reason IF cannot be considered a standard Pascal Function.


Identifier Functions
--------------------
The capability of the parser to recognise artibrary identifiers may be extended
by the use to an Identifier function. This is a powerful mechanism, but neither
simple not particularly intuitive.

In order to really make the most of the identifier function you need to know more
about how the parser works. When the parser comes across a token which is does not
recognise as a literal, operator, or standard function, it calls the identifier
function. It is important to remember that the identifier function is only called when
the input string, S, is parsed i.e. the result of a call to CreateExpression is being
constructed. Once GetExpression has returned the identifier function is not called.
In particular the identifier function is not called when an expression is evaluated.

This distinction between the time when an expression is created (let's call it 'parse-time')
and when it is evaluated ('evaluate-time') is important, particularly if the result of a
call to CreateExpression is saved for future evaluation rather than simply evaluated then
thrown away.

This difference between 'parse-time' and 'evaluate-time' is important when considering
how to handle non-standard identifiers.

'Constant' identifiers
----------------------
It may be that you wish to substitute a constant expression for an identifier when
a given string is parsed, and do not expect the value of the resultant expression to change
during the lifetime of the result (of the call to CreateExpression). This lifetime might
be really short, as in Example1 above or it might be the lifetime of your program.
This sort of constant substitution is quite easy to do.

Consider the following example of an identifier function.

Example 2. Constant Substitution
--------------------------------

function TForm1.EG2IDFunc( const Identifier: String;
                              ParameterList: TParameterList): TExpression;
begin
  if Assigned(ParameterList) then
    raise EExpression.CreateFmt('Identifier %s does not require parameters', [Identifier]);
  if Identifier = 'SC' then
    Result:= TStringLiteral.Create('This is a string')
  else
  if Identifier = 'FC' then
    Result:= TFloatLiteral.Create(8.9)
  else
  if Identifier = 'IC' then
    Result:= TIntegerLiteral.Create(42)
  else
  if Identifier = 'BC' then
    Result:= TBooleanLiteral.Create(False)
  else
    Result:= nil
end;

procedure TForm1.EG2ButtonClick(Sender: TObject);
var
  s: String;
  E: TExpression;
begin
  s:= '';
  if InputQuery('Example 2', 'Expression may contain' +
     ' SC, FC, IC or BC', s) then
  begin
    E:= CreateExpression(s, EG2IDFunc);
    if Assigned(E) then
    try
      MessageDlg(
        Format('E.AsString = %s E.ExprType = %s',
               [E.AsString, NExprType[E.ExprType]]),
        mtInformation, [mbOK], 0)
    finally
      E.Free
    end
  end
end;

Note that the IdentifierFunction (in this case EG2IDFunc) is implemented and then its address
is passed to CreateExpression. The identifier function is called whenever the parser
(CreateExpression) encounters an unknown identifier. Note that the additional identifiers do
not require parameters, so if a parameter list is passed to the EG2IDFunc, an exception is
raised. This step is important as if a parameter list is passed, and the the identifier list
returns non-nil, then disposal of this list is the responsibility of the Identifier function
or the expression it creates. See note on 'Supporting Parameters' below.

It is most important to appreciate that the string passed to the Identifier function as
Identifier is always in UPPER CASE regardless of its case in the expression. As in Pascal
identifiers are case insensitive in expressions.


The expression returned by the IdentifierFunction must be Created by that call. Unless you
are very sure what you are doing, you should not return a pointer to an expression already
instantiated. This is because Expressions are more often than not, binary trees, containing
pointers to many sub expressions. When an expression is freed, all its branches are freed
also, including any which may have been created by a call to an IdentifierFunction.

Note that there is no reason why the IdentifierFunction cannot call CreateExpression to obtain
a result. An Alternative implementation of the Identifier function above might be:

function TForm1.EG2IDFunc( const Identifier: String;
                              ParameterList: TParameterList): TExpression;
begin
  if Assigned(ParameterList) then
    raise EExpression.CreateFmt('Identifier %s does not require parameters', [Identifier]);
  if Identifier = 'SC' then
    Result:= CreateExpression('''This is a string''', nil)
  else
  if Identifier = 'FC' then
    Result:= CreateExpression('8.9', nil)
  else
  if Identifier = 'IC' then
    Result:= CreateExpression(42, nil)
  else
  if Identifier = 'BC' then
    Result:= CreateExpression('False', nil)
  else
    Result:= nil
end;

If an identifier expression calls CreateExpression it can pass itself as an identifier
expression. If, however, the implementation of a particular identifier depends on that same
identifier you will (obviously) get an infinite recursive loop. (Aside: Win95 can readjust
its own stack and an infinite recusive loop will swallow up to a 1MB of stack before
raising an exception. This can take some time, and it is possible to be misled into thinking
that your program has hung when it fact it is simply busy consuming stack)

Example 3 Getting a value at 'evaluate-time'
--------------------------------------------
There may be circumstances when you want a particular identifier to represent a value that
may change during the lifetime of your program, and you cannot afford the computational
overhead of creating a new expression (by parsing a string) each time you want to evaluate
the expression. In order to do this, you need to derive a descendent of TExpression. In
the following simple example we define TTimeString = class(TExpression). This Expression
has type ttString and returns the current time as a string in the format hh:mm:ss.
The Identifier function EG3IDFunc returns an Expression of type TTimeString when passed
an identifier of 'TIMESTRING' (NOTE: not 'TimeString'!)

When we click EG3Button we are prompted to enter an expression which is parsed and assigned
to the variable EG3Expr (a field of TForm1). EG3Timer executes EG3TimerTimer every 5 seconds
which evaluates the value of EG3Expr.AsString and assigns it to EG3Result.Caption. The
important thing to note is that although EG3Expr is created only when EG3Button is clicked, if
the string from which EG3Expr is derived contains the token TimeString then each time
EG3Expr.AsString is evaluated, its value is different, depending on the system time.

Try entering an expression like

'The time is now ' + TimeString

for example 3.

type
  TTimeString =
  class(TExpression)
  protected
    function GetAsString: String; override;
    function GetExprType: TExprType; override;
  end;

function TTimeString.GetAsString: String;
begin
  Result:= FormatDateTime('hh:mm:ss', SysUtils.Time)
end;

function TTimeString.GetExprType: TExprType;
begin
  Result:= ttString
end;

function TForm1.EG3IDFunc( const Identifier: String;
                              ParameterList: TParameterList): TExpression;
begin
  if Assigned(ParameterList) then
    raise EExpression.CreateFmt('Identifier %s does not require parameters', [Identifier]);
  if Identifier = 'TIMESTRING' then
    Result:= TTimeString.Create
  else
    Result:= nil
end;

procedure TForm1.EG3TimerTimer(Sender: TObject);
begin
  if Assigned(EG3Expr) then
    EG3Result.Caption:= EG3Expr.AsString
  else
    EG3Result.Caption:= 'EG3 not running'
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  EG3Expr.Free
end;


procedure TForm1.EG3ButtonClick(Sender: TObject);
var
  s: String;
begin
  s:= 'TimeString';
  if InputQuery('Example 3', 'Expression may contain' +
     ' TimeString', s) then
  begin
    EG3Expr.Free;
    EG3Expr:= CreateExpression(s, EG3IDFunc);
    CheckInstances
  end
end;


Using Parameter Lists
---------------------
It may be that you wish to define a custom function which has an arbitrary number and type
of parameters. In your expression this might look like

   MyFunc(10*2 + 3, 'A String', True)

Upon encountering a construct like this, CreateExpression will construct a parameter list
before calling the Identifier Function. A Parameter list is not an Expression, it is a
descendent of TList which contains expressions, one for each parameter. The parameter list
disposes of its expressions when it is freed.

If the identifier function returns nil, or raises an exception then CreateExpression will
free the parameter list. Otherwise, it is assumed that the parameter list becomes the
responsibility of the Identifier Function or its result. The issue of disposal of Parameter
lists is complicated and poorly implemented by this unit (fair cop, guv'nor) There is
further discussion on this topic in the 'General Notes' at the end of this file.

The Identifer function may elect to examine the parameter list, and then discard it, ignore it
altogther, or save it to refer to later (at 'evaluate-time'). If the parameter list is
required later, then it can be saved as a field of the Expression which is returned by the
Identifier Function. Generally, this will be a descendent of TFunction (above). TFunction is
an abstract - it differs from TExpression in that it has inbuilt mechanisms for handling
parameters: you can pass in a parameter list when you construct it and the list will be freed
by TFunction.Destroy.

Example 4 - Parameters
----------------------
The following example uses parameters to construct a constant expression within an Identifier
function. The identifier function disposes of the parameter list: the example uses no
descendent of TFunction. To see how to implement a descendent of TFunction and
refer to a parameter list at 'evaluate-time' examine the implementations of the standard
functions.

We want CreateExpression to recognise the following function

function Mean(a, b: Float): Float;
begin
  Result:= (a + b)/2
end;


function TForm1.EG4IDFunc( const Identifier: String;
                              ParameterList: TParameterList): TExpression;
begin
  if Identifier = 'MEAN' then
  begin
    if Assigned(ParameterList) and
       (ParameterList.Count = 2) then
    begin
      with ParameterList do
        Result:= TFloatLiteral.Create((AsFloat[0] + AsFloat[1])/2);
      ParameterList.Free
    end else
    begin
      raise EExpression.CreateFmt('Invalid Parameters to %s', [Identifier]);
    end;
  end else
  begin
    Result:= nil
  end
end;

The interesting things to note about EG4IDFunc are the following:
the parameters are evaluated at 'parse-time' i.e before CreateExpression returns. The results
are then used to create a literal float expression to return. The value of this expression
will not now change within the lifetime of its 'parent' expression. Because the EG4IDFunc does
not return a descendent of TFunction, and does not refer to its Parameter list at
'evaluate-time' it needs to dispose of its parameter list before it returns. This task would
'normally' be handled by TFunction.Destroy if EG4IDFunc suceeds. If EG4IDFunc fails
(raises an exception or returns nil) then this duty is carried out by the caller, generally
CreateExpression.

procedure TForm1.EG4ButtonClick(Sender: TObject);
var
  s: String;
  E: TExpression;
begin
  s:= '';
  if InputQuery('Example 4', 'Expression may contain ' +
     'Mean(a, b: Float)', s) then
  begin
    E:= CreateExpression(s, EG4IDFunc);
    if Assigned(E) then
    try
      MessageDlg(
        Format('E.AsString = %s E.ExprType = %s',
               [E.AsString, NExprType[E.ExprType]]),
        mtInformation, [mbOK], 0)
    finally
      E.Free
    end
  end
end;


Other Ideas
-----------

There is a lot of scope for extending the parser/evaluator presented here. I have already
implemented a version which handles Date and Time computations. An Identifier function
might be written to recognise field names and extract values from a database table at
evaluate time. These sorts of things are not difficult.

I have written spreadsheet-like applications using this unit and it might be useful to
implement more Spreadsheet type functions as standard.
}


implementation
type
  TOperator = ( opNot,
                opMult, opDivide, opDiv, opMod, opAnd, opShl, opShr,
                opPlus, opMinus, opOr, opXor,
                opEq, opNEQ, opLT, opGT, opLTE, opGTE);
  TUnaryOp =
  class(TExpression)
  private
    Operand: TExpression;
    OperandType: TExprType;
    Operator: TOperator;
  protected
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetAsBoolean: Boolean; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aOperator: TOperator; aOperand: TExpression);
    destructor Destroy; override;
  end;

  TBinaryOp =
  class(TExpression)
  private
    Operand1, Operand2: TExpression;
    Operator: TOperator;
    OperandType: TExprType;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetAsBoolean: Boolean; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aOperator: TOperator; aOperand1, aOperand2: TExpression);
    destructor Destroy; override;
  end;

  TRelationalOp =
  class(TExpression)
  private
    Operand1, Operand2: TExpression;
    Operator: TOperator;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetAsBoolean: Boolean; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aOperator: TOperator; aOperand1, aOperand2: TExpression);
    destructor Destroy; override;
  end;

const
  NOperator: array[TOperator] of String =
              ( 'opNot',
                'opMult', 'opDivide', 'opDiv', 'opMod', 'opAnd', 'opShl', 'opShr',
                'opPlus', 'opMinus', 'opOr', 'opXor',
                'opEq', 'opNEQ', 'opLT', 'opGT', 'opLTE', 'opGTE');

  UnaryOperators = [opNot];
  MultiplyingOperators = [opMult, opDivide, opDiv, opMod, opAnd, opShl, opShr];
  AddingOperators = [opPlus, opMinus, opOr, opXor];
  RelationalOperators = [opEQ, opNEQ, opLT, opGT, opLTE, opGTE];

  NBoolean: array[Boolean] of String[5] = ('FALSE', 'TRUE');


function ResultType( Operator: TOperator; OperandType: TExprType): TExprType;
procedure NotAppropriate;
begin
  Result:= ttString;
  raise EExpression.CreateFmt( 'Operator %s incompatible with %s',
                               [NOperator[Operator], NExprType[OperandType]])
end;

begin
  case OperandType of
    ttString:
    case Operator of
      opPlus: Result:= ttString;
      opEq..opGTE: Result:= ttBoolean;
    else
      NotAppropriate;
    end;
    ttFloat:
    case Operator of
      opMult, opDivide, opPlus, opMinus: Result:= ttFloat;
      opEq..opGTE: Result:= ttBoolean;
    else
      NotAppropriate;
    end;
    ttInteger:
    case Operator of
      opNot, opMult, opDiv, opMod, opAnd, opShl, opShr, opPlus, opMinus,
      opOr, opXor: Result:= ttInteger;
      opDivide: Result:= ttFloat;
      opEq..opGTE: Result:= ttBoolean;
    else
      NotAppropriate;
    end;
    ttBoolean:
    case Operator of
      opNot, opAnd, opOr, opXor, opEq, opNEQ: Result:= ttBoolean;
    else
      NotAppropriate;
    end;
  end
end;

function CommonType( Op1Type, Op2Type: TExprType): TExprType;
begin
  if Op1Type < Op2Type then
    Result:= Op1Type else
    Result:= Op2Type
end;

procedure Internal( Code: Integer);
begin
  raise EExpression.CreateFmt('Internal parser error. Code %d', [Code])
end;

constructor TExpression.Create;
begin
  inherited Create;
  Inc(InstanceCount)
end;

destructor TExpression.Destroy;
begin
  Dec(InstanceCount);
  inherited Destroy
end;


function TExpression.GetAsString: String;
begin
  case ExprType of
    ttString: raise EExpression.CreateFmt('Cannot read %s as String',
                                              [NExprType[ExprType]]);
    ttFloat: Result:= FloatToStr(AsFloat);
    ttInteger: Result:= IntToStr(AsInteger);
    ttBoolean: Result:= NBoolean[AsBoolean];
  end
end;

function TExpression.GetAsFloat: Double;
begin
  Result:= 0;
  case ExprType of
    ttString, ttFloat:
      raise EExpression.CreateFmt('Cannot read %s as Float',
                                   [NExprType[ExprType]]);
    ttInteger, ttBoolean: Result:= AsInteger;
  end
end;

function TExpression.GetAsInteger: Integer;
begin
  Result:= 0;
  case ExprType of
    ttString, ttFloat, ttInteger:
       raise EExpression.CreateFmt('Cannot read %s as integer',
                               [NExprType[ExprType]]);
    ttBoolean: Result:= Integer(AsBoolean);
  end;
end;

function TExpression.GetAsBoolean: Boolean;
begin
  raise EExpression.CreateFmt('Cannot read %s as boolean',
                               [NExprType[ExprType]])
end;

function TExpression.CanReadAs(aExprType: TExprType): Boolean;
begin
  Result:= Ord(ExprType) >= Ord(aExprType)
end;

function TStringLiteral.GetAsString: String;
begin
  Result:= FAsString
end;

function TStringLiteral.GetExprType: TExprType;
begin
  Result:= ttString
end;

constructor TStringLiteral.Create( aAsString: String);
begin
  inherited Create;
  FAsString:= aAsString
end;

function TFloatLiteral.GetAsString: String;
begin
  Result:= FloatToStr(FAsFloat)
end;

function TFloatLiteral.GetAsFloat: Double;
begin
  Result:= FAsFloat
end;

function TFloatLiteral.GetExprType: TExprType;
begin
  Result:= ttFloat
end;

constructor TFloatLiteral.Create( aAsFloat: Double);
begin
  inherited Create;
  FAsFloat:= aAsFloat
end;

function TIntegerLiteral.GetAsString: String;
begin
  Result:= FloatToStr(FAsInteger)
end;

function TIntegerLiteral.GetAsFloat: Double;
begin
  Result:= FAsInteger
end;

function TIntegerLiteral.GetAsInteger: Integer;
begin
  Result:= FAsInteger
end;

function TIntegerLiteral.GetExprType: TExprType;
begin
  Result:= ttInteger
end;

constructor TIntegerLiteral.Create( aAsInteger: Integer);
begin
  inherited Create;
  FAsInteger:= aAsInteger
end;

function TBooleanLiteral.GetAsString: String;
begin
  Result:= NBoolean[FAsBoolean]
end;

function TBooleanLiteral.GetAsFloat: Double;
begin
  Result:= GetAsInteger
end;

function TBooleanLiteral.GetAsInteger: Integer;
begin
  Result:= Integer(FAsBoolean)
end;

function TBooleanLiteral.GetAsBoolean: Boolean;
begin
  Result:= FAsBoolean
end;

function TBooleanLiteral.GetExprType: TExprType;
begin
  Result:= ttBoolean
end;

constructor TBooleanLiteral.Create( aAsBoolean: Boolean);
begin
  inherited Create;
  FAsBoolean:= aAsBoolean
end;

function TUnaryOp.GetAsFloat: Double;
begin
  case Operator of
    opMinus: Result:= -Operand.AsFloat;
    opPlus: Result:= Operand.AsFloat;
  else
    Result:= inherited GetAsFloat;
  end
end;

function TUnaryOp.GetAsInteger: Integer;
begin
  Result:= 0;
  case Operator of
    opMinus: Result:= -Operand.AsInteger;
    opPlus: Result:= Operand.AsInteger;
    opNot:
    case OperandType of
      ttInteger: Result:= not Operand.AsInteger;
      ttBoolean: Result:= Integer(AsBoolean);
    else
      Internal(6);
    end;
  else
    Result:= inherited GetAsInteger;
  end
end;

function TUnaryOp.GetAsBoolean: Boolean;
begin
  case Operator of
    opNot: Result:= not(Operand.AsBoolean)
  else
    Result:= inherited GetAsBoolean;
  end
end;

function TUnaryOp.GetExprType: TExprType;
begin
  Result:= ResultType(Operator, OperandType)
end;

constructor TUnaryOp.Create( aOperator: TOperator; aOperand: TExpression);
begin
  inherited Create;
  Operand:= aOperand;
  Operator:= aOperator;
  OperandType:= Operand.ExprType;
  if not (Operator in [opNot, opPlus, opMinus]) then
    raise EExpression.CreateFmt('%s is not simple unary operator',
                                [NOperator[Operator]])
end;

destructor TUnaryOp.Destroy;
begin
  Operand.Free;
  inherited Destroy
end;

function TBinaryOp.GetAsString: String;
begin
  Result:= '';
  case ExprType of
    ttString:
      case Operator of
        opPlus: Result:= Operand1.AsString + Operand2.AsString;
      else
        Internal(10);
      end;
    ttFloat:
      Result:= FloatToStr(AsFloat);
    ttInteger:
      Result:= IntToStr(AsInteger);
    ttBoolean:
      Result:= NBoolean[AsBoolean];
  end
end;

function TBinaryOp.GetAsFloat: Double;
begin
  Result:= 0;
  case ExprType of
    ttFloat:
      case Operator of
        opPlus: Result:= Operand1.AsFloat + Operand2.AsFloat;
        opMinus: Result:= Operand1.AsFloat - Operand2.AsFloat;
        opMult: Result:= Operand1.AsFloat * Operand2.AsFloat;
        opDivide: Result:= Operand1.AsFloat / Operand2.AsFloat;
      else
        Internal(11);
      end;
    ttInteger:
        Result:= AsInteger;
    ttBoolean:
       Result:= Integer(AsBoolean);
  end
end;


function TBinaryOp.GetAsInteger: Integer;
begin
  Result:= 0;
  case ExprType of
    ttInteger:
    case Operator of
      opPlus: Result:= Operand1.AsInteger + Operand2.AsInteger;
      opMinus: Result:= Operand1.AsInteger - Operand2.AsInteger;
      opMult: Result:= Operand1.AsInteger * Operand2.AsInteger;
      opDiv: Result:= Operand1.AsInteger div Operand2.AsInteger;
      opMod: Result:= Operand1.AsInteger mod Operand2.AsInteger;
      opShl: Result:= Operand1.AsInteger shl Operand2.AsInteger;
      opShr: Result:= Operand1.AsInteger shr Operand2.AsInteger;
      opAnd: Result:= Operand1.AsInteger and Operand2.AsInteger;
      opOr: Result:= Operand1.AsInteger or Operand2.AsInteger;
      opXor: Result:= Operand1.AsInteger xor Operand2.AsInteger;
    else
      Internal(12);
    end;
    ttBoolean:
      Result:= Integer(GetAsBoolean);
  end
end;

function TBinaryOp.GetAsBoolean: Boolean;
begin
  Result:= false;
  case Operator of
    opAnd: Result:= Operand1.AsBoolean and Operand2.AsBoolean;
    opOr: Result:= Operand1.AsBoolean or Operand2.AsBoolean;
    opXor: Result:= Operand1.AsBoolean xor Operand2.AsBoolean;
  else
    Internal(13);
  end
end;

function TBinaryOp.GetExprType: TExprType;
begin
  GetExprType:= ResultType(Operator, OperandType)
end;

constructor TBinaryOp.Create( aOperator: TOperator; aOperand1, aOperand2: TExpression);
begin
  inherited Create;
  Operator:= aOperator;
  Operand1:= aOperand1;
  Operand2:= aOperand2;
  OperandType:= CommonType(Operand1.ExprType, Operand2.ExprType);
  if not (Operator in [opMult..opXor]) then
    raise EExpression.CreateFmt('%s is not a simple binary operator',
              [NOperator[Operator]])
end;

destructor TBinaryOp.Destroy;
begin
  Operand1.Free;
  Operand2.Free;
  inherited Destroy
end;

function TRelationalOp.GetAsString: String;
begin
  Result:= NBoolean[AsBoolean]
end;

function TRelationalOp.GetAsFloat: Double;
begin
  Result:= Integer(AsBoolean)
end;

function TRelationalOp.GetAsInteger: Integer;
begin
  Result:= Integer(AsBoolean)
end;

function TRelationalOp.GetAsBoolean: Boolean;
begin
  Result:= false;
  case CommonType(Operand1.ExprType, Operand2.ExprType) of
    ttBoolean:
    case Operator of
      opEQ: Result:= Operand1.AsBoolean = Operand2.AsBoolean;
      opNEQ: Result:= Operand1.AsBoolean <> Operand2.AsBoolean;
    else
      raise EExpression.CreateFmt('cannot apply %s to boolean operands',
                                  [NOperator[Operator]]);
    end;

    ttInteger:
    case Operator of
      opLT: Result:= Operand1.AsInteger < Operand2.AsInteger;
      opLTE: Result:= Operand1.AsInteger <= Operand2.AsInteger;
      opGT: Result:= Operand1.AsInteger > Operand2.AsInteger;
      opGTE: Result:= Operand1.AsInteger >= Operand2.AsInteger;
      opEQ: Result:= Operand1.AsInteger = Operand2.AsInteger;
      opNEQ: Result:= Operand1.AsInteger <> Operand2.AsInteger;
    end;

    ttFloat:
    case Operator of
      opLT: Result:= Operand1.AsFloat < Operand2.AsFloat;
      opLTE: Result:= Operand1.AsFloat <= Operand2.AsFloat;
      opGT: Result:= Operand1.AsFloat > Operand2.AsFloat;
      opGTE: Result:= Operand1.AsFloat >= Operand2.AsFloat;
      opEQ: Result:= Operand1.AsFloat = Operand2.AsFloat;
      opNEQ: Result:= Operand1.AsFloat <> Operand2.AsFloat;
    end;

    ttString:
    case Operator of
      opLT: Result:= Operand1.AsString < Operand2.AsString;
      opLTE: Result:= Operand1.AsString <= Operand2.AsString;
      opGT: Result:= Operand1.AsString > Operand2.AsString;
      opGTE: Result:= Operand1.AsString >= Operand2.AsString;
      opEQ: Result:= Operand1.AsString = Operand2.AsString;
      opNEQ: Result:= Operand1.AsString <> Operand2.AsString;
    end;
  end
end;

function TRelationalOp.GetExprType: TExprType;
begin
  Result:= ttBoolean
end;

constructor TRelationalOp.Create( aOperator: TOperator; aOperand1, aOperand2: TExpression);
begin
  inherited Create;
  Operator:= aOperator;
  Operand1:= aOperand1;
  Operand2:= aOperand2;
  if not (Operator in RelationalOperators) then
    raise EExpression.CreateFmt('%s is not relational operator',
                                 [NOperator[Operator]])
end;

destructor TRelationalOp.Destroy;
begin
  Operand1.Free;
  Operand2.Free;
  inherited Destroy
end;

function TParameterList.GetAsString(i: Integer): String;
begin
  Result:= Param[i].AsString
end;

function TParameterList.GetAsFloat(i: Integer): Double;
begin
  Result:= Param[i].AsFloat
end;

function TParameterList.GetAsInteger(i: Integer): Integer;
begin
  Result:= Param[i].AsInteger
end;

function TParameterList.GetAsBoolean(i: Integer): Boolean;
begin
  Result:= Param[i].AsBoolean
end;

function TParameterList.GetExprType(i: Integer): TExprType;
begin
  Result:= Param[i].ExprType
end;

function TParameterList.GetParam(i: Integer): TExpression;
begin
  Result:= TExpression(Items[i])
end;

destructor TParameterList.Destroy;
var
  i: Integer;
begin
  for i:= 0 to (Count - 1) do
    TObject(Items[i]).Free;
  inherited Destroy
end;

function TFunction.GetParam(n: Integer): TExpression;
begin
  Result:= FParameterList.Param[n]
end;

function TFunction.ParameterCount: Integer;
begin
  if Assigned(FParameterList) then
    ParameterCount:= FParameterList.Count
  else
    ParameterCount:= 0
end;

constructor TFunction.Create( aParameterList: TParameterList);
begin
  inherited Create;
  FParameterList:= aParameterList
end;

destructor TFunction.Destroy;
begin
  FParameterList.Free;
  inherited Destroy
end;

type
  TTypeCast =
  class(TFunction)
  private
    Operator: TExprType;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetAsBoolean: Boolean; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aParameterList: TParameterList;
                        aOperator: TExprType);
  end;

  TMF =
    (mfTrunc, mfRound, mfAbs, mfArcTan, mfCos, mfExp, mfFrac, mfInt,
     mfLn, mfPi, mfSin, mfSqr, mfSqrt, mfPower);

  TMathExpression =
  class(TFunction)
  private
    Operator: TMF;
    procedure CheckParameters;
  protected
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aParameterList: TParameterList;
                        aOperator: TMF);
  end;

  TSF =
    (sfUpper, sfLower, sfCopy, sfPos, sfLength);

  TStringExpression =
  class(TFunction)
  private
    Operator: TSF;
    procedure CheckParameters;
  protected
    function GetAsString: String; override;
    function GetAsInteger: Integer; override;
    function GetExprType: TExprType; override;
  public
    constructor Create( aParameterList: TParameterList;
                        aOperator: TSF);
  end;


  TConditional =
  class(TFunction)
  private
    procedure CheckParameters;
    function Rex: TExpression;
  protected
    function GetAsString: String; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Integer; override;
    function GetAsBoolean: Boolean; override;
    function GetExprType: TExprType; override;
  public
  end;

const
  NTypeCast: array[TExprType] of PChar =
    ('STRING', 'FLOAT', 'INTEGER', 'BOOLEAN');
  NMF: array[TMF] of PChar =
    ('TRUNC', 'ROUND', 'ABS', 'ARCTAN', 'COS', 'EXP', 'FRAC', 'INT',
     'LN', 'PI', 'SIN', 'SQR', 'SQRT', 'POWER');
  NSF: array[TSF] of PChar = ('UPPER', 'LOWER', 'COPY', 'POS', 'LENGTH');

function TStringExpression.GetAsString: String;
begin
  CheckParameters;
  case Operator of
    sfUpper: Result:= UpperCase(Param[0].AsString);
    sfLower: Result:= LowerCase(Param[0].AsString);
    sfCopy: Result:=  Copy(Param[0].AsString, Param[1].AsInteger, Param[2].AsInteger);
  else
    Result:= inherited GetAsString;
  end
end;

function TStringExpression.GetAsInteger: Integer;
begin
  CheckParameters;
  case Operator of
    sfPos: Result:= Pos(Param[0].AsString, Param[1].AsString);
    sfLength: Result:= Length(Param[0].AsString);
  else
    Result:= inherited GetAsInteger
  end
end;

function TStringExpression.GetExprType: TExprType;
begin
  case Operator of
    sfUpper, sfLower, sfCopy: Result:= ttString;
  else
    Result:= ttInteger;
  end
end;

procedure TStringExpression.CheckParameters;
var
  OK: Boolean;
begin
  OK:= false;
  case Operator of
    sfUpper, sfLower, sfLength:
      OK:= (ParameterCount = 1) and
           (Param[0].ExprType >= ttString);
    sfCopy:
      OK:= (ParameterCount = 3) and
           (Param[0].ExprType >= ttString) and
           (Param[1].ExprType >= ttInteger) and
           (Param[2].ExprType >= ttInteger);
    sfPos:
      OK:= (ParameterCount = 2) and
           (Param[0].ExprType >= ttString) and
           (Param[1].ExprType >= ttString);
  end;
  if not OK then
    raise EExpression.CreateFmt('Invalid parameter to %s',
                                [NSF[Operator]])
end;

constructor TStringExpression.Create( aParameterList: TParameterList;
                                      aOperator: TSF);
begin
  inherited Create(aParameterList);
  Operator:= aOperator
end;

function TMathExpression.GetAsFloat: Double;
begin
  CheckParameters;
  case Operator of
    mfAbs: Result:= Abs(Param[0].AsFloat);
    mfArcTan: Result:= ArcTan(Param[0].AsFloat);
    mfCos: Result:= Cos(Param[0].AsFloat);
    mfExp: Result:= Exp(Param[0].AsFloat);
    mfFrac: Result:= Frac(Param[0].AsFloat);
    mfInt: Result:= Int(Param[0].AsFloat);
    mfLn: Result:= Ln(Param[0].AsFloat);
    mfPi: Result:= Pi;
    mfSin: Result:= Sin(Param[0].AsFloat);
    mfSqr: Result:= Sqr(Param[0].AsFloat);
    mfSqrt: Result:= Sqrt(Param[0].AsFloat);
    mfPower: Result:=  Exp(Param[1].AsFloat * Ln(Param[0].AsFloat))
  else
    Result:= inherited GetAsFloat;
  end
end;

function TMathExpression.GetAsInteger: Integer;
begin
  CheckParameters;
  case Operator of
    mfTrunc: Result:= Trunc(Param[0].AsFloat);
    mfRound: Result:= Round(Param[0].AsFloat);
    mfAbs: Result:= Abs(Param[0].AsInteger);
  else
    Result:= inherited GetAsInteger;
  end
end;

procedure TMathExpression.CheckParameters;
var
  OK: Boolean;
begin
  OK:= True;
  case Operator of
    mfTrunc, mfRound, mfArcTan, mfCos, mfExp, mfFrac, mfInt,
    mfLn, mfSin, mfSqr, mfSqrt, mfAbs:
    begin
      OK:= (ParameterCount = 1) and
           (Param[0].ExprType >= ttFloat);
    end;
    mfPower:
    begin
      OK:= (ParameterCount = 2) and
           (Param[0].ExprType >= ttFloat) and
           (Param[1].ExprType >= ttFloat);
    end;
  end;
  if not OK then
    raise EExpression.CreateFmt('Invalid parameter to %s',
                                [NMF[Operator]])
end;

function TMathExpression.GetExprType: TExprType;
begin
  case Operator of
    mfTrunc, mfRound: Result:= ttInteger;
  else
    Result:= ttFloat;
  end
end;

constructor TMathExpression.Create( aParameterList: TParameterList;
                                    aOperator: TMF);
begin
  inherited Create(aParameterList);
  Operator:= aOperator
end;


function TTypeCast.GetAsString: String;
begin
  Result:= Param[0].AsString
end;

function TTypeCast.GetAsFloat: Double;
begin
  Result:= Param[0].AsFloat
end;

function TTypeCast.GetAsInteger: Integer;
begin
  Result:= Param[0].AsInteger
end;

function TTypeCast.GetAsBoolean: Boolean;
begin
  Result:= Param[0].AsBoolean
end;

function TTypeCast.GetExprType: TExprType;
begin
  Result:= Operator
end;

constructor TTypeCast.Create( aParameterList: TParameterList;
                              aOperator: TExprType);
begin
  inherited Create(aParameterList);
  Operator:= aOperator
end;

function TConditional.Rex: TExpression;
begin
  CheckParameters;
  if Param[0].AsBoolean then
    Result:= Param[1] else
    Result:= Param[2]
end;


procedure TConditional.CheckParameters;
begin
  if not ((ParameterCount = 3) and
          (Param[0].ExprType = ttBoolean)) then
    raise EExpression.Create('Invalid parameters to If')
end;

function TConditional.GetAsString: String;
begin
  Result:= Rex.AsString
end;

function TConditional.GetAsFloat: Double;
begin
  Result:= Rex.AsFloat
end;
function TConditional.GetAsInteger: Integer;
begin
  Result:= Rex.AsInteger
end;
function TConditional.GetAsBoolean: Boolean;
begin
  Result:= Rex.AsBoolean
end;
function TConditional.GetExprType: TExprType;
begin
  Result:= Rex.ExprType
end;

function StandardFunctions (const Ident: String; PL: TParameterList): TExpression;
var
  i: TExprType;
  j: TMF;
  k: TSF;
  Found: Boolean;
begin
  Found:= false;
  if Ident = 'IF' then
  begin
    Result:= TConditional.Create(PL)
  end else
  begin
    for i:= Low(TExprType) to High(TExprType) do
    begin
      if Ident = NTypeCast[i] then
      begin
        Found:= true;
        Break
      end;
    end;
    if Found then
    begin
      Result:= TTypeCast.Create(PL, i)
    end else
    begin
      for j:= Low(TMF) to High(TMF) do
      begin
        if Ident = NMF[j] then
        begin
          Found:= true;
          break
        end
      end;
      if Found then
      begin
        Result:= TMathExpression.Create(PL, j)
      end else
      begin
        for k:= Low(TSF) to High(TSF) do
        begin
          if Ident = NSF[k] then
          begin
            Found:= true;
            break
          end
        end;
        if Found then
        begin
          Result:= TStringExpression.Create(PL, k)
        end else
        begin
          Result:= nil
        end
      end
    end
  end
end;

{parser...}
const
  OpTokens: array[TOperator] of PChar =
              ( 'NOT',
                '*', '/', 'DIV', 'MOD', 'AND', 'SHL', 'SHR',
                '+', '-', 'OR', 'XOR',
                '=', '<>', '<', '>', '<=', '>=');
const
  Whitespace = [#$1..#$20];
  Digits = ['0'..'9'];
  SignChars = ['+', '-'];
  RelationalChars = ['<', '>', '='];
  OpChars = SignChars + ['/', '*'] + RelationalChars;

  OpenSub = '(';
  CloseSub = ')';
  SQuote = '''';
  PrimaryIdentChars = ['a'..'z', 'A'..'Z', '_'];
  IdentChars = PrimaryIdentChars + Digits;

function CreateExpression( const S: String;
                IdentifierFunction: TIdentifierFunction): TExpression;

var
  P: PChar;

function Expression: TExpression;

procedure SwallowWhitespace;
begin
  while P^ in Whitespace do inc(P)
end;

function EoE: Boolean;
begin
  Result:= (P^ = #0) or (P^ = CloseSub) or (P^ = ',')
end;

function UnsignedFloat: TExpression;
type
  TNScan = (nsMantissa, nsDPFound, nsExpFound, nsFound);
var
  S: String[30];
  State: TNScan;
  Int: Boolean;

procedure Bomb;
begin
  raise EExpression.Create('Bad numeric format')
end;

begin
  S:= '';
  Int:= false;
  State:= nsMantissa;
  repeat
    if P^ in Digits then
    begin
      S:= S + P^;
      inc(P)
    end else
    if P^ = '.' then
    begin
      if State = nsMantissa then
      begin
        S:= S + P^;
        inc(P);
        State:= nsDPFound
      end else
      begin
        Bomb
      end;
    end else
    if (P^ = 'e') or (P^ = 'E') then
    begin
      if (State = nsMantissa) or
         (State = nsDPFound) then
      begin
        S:= S + 'E';
        inc(P);
        if P^ = '-' then
        begin
          S:= S + P^;
          inc(P);
        end;
        State:= nsExpFound;
        if not (P^ in Digits) then
          Bomb
      end else
      begin
        Bomb
      end
    end else
    begin
      Int:= (State = nsMantissa);
      State:= nsFound
    end;
    if Length(S) > 28 then
      Bomb
  until State = nsFound;
  if Int then
    Result:= TIntegerLiteral.Create(StrToInt(S))
  else
    Result:= TFloatLiteral.Create(StrToFloat(S))
end;

function CharacterString: TExpression;
var
  SR: String;
begin
  SR:= '';
  repeat
    inc(P);
    if P^ = SQuote then
    begin
     inc(P);
      if P^ <> SQuote then
        break;
     end;
     if P^ = #0 then
       raise EExpression.Create('Unterminated string');
     if Length(SR) > MaxStringLength then
       raise EExpression.Create('String too long');
     SR:= SR + P^;
  until false;
  Result:= TStringLiteral.Create(SR)
end;

type
  TTokType = (ttIdentifier, ttOperator, ttBooleanLiteral);

function GetTok( var Ident: String;
                 var Operator: TOperator;
                 var BoolLit: Boolean): TTokType;
var
  Found: Boolean;
  LocalOp: TOperator;
begin
  Found:= false;
  Ident:= UpCase(P^);
  Result:= ttIdentifier;
  repeat
    inc(P);
    if P^ in IdentChars then
      Ident:= Ident + UpCase(P^)
    else
      Found:= true
  until Found;

  for LocalOp:= Low(TOperator) to High(TOperator) do
  begin
    if OpTokens[LocalOp] = Ident then
    begin
      Result:= ttOperator;
      Operator:= LocalOp;
      break
    end;
  end;

  if Result = ttIdentifier then
  begin
    if Ident = 'TRUE' then
    begin
      Result:= ttBooleanLiteral;
      BoolLit:= true
    end else
    if Ident = 'FALSE' then
    begin
      Result:= ttBooleanLiteral;
      BoolLit:= false
    end
  end
end;

function Factor: TExpression;
var
{from GetTok}
  Identifier: String;
  Operator: TOperator;
  BoolLit: Boolean;
  PList: TParameterList;
  MoreParameters: Boolean;
begin {factor}
  Result:= nil;
  try
    SwallowWhitespace;
    if P^ in SignChars then
    begin
      case P^ of
        '+':
        begin
          Inc(P);
          Result:= TUnaryOp.Create(opPlus, Factor);
        end;
        '-':
        begin
          Inc(P);
          Result:= TUnaryOp.Create(opMinus, Factor);
        end;
      end
    end else
    if P^ = SQuote then
    begin
      Result:= CharacterString;
    end else
    if P^ in Digits then
    begin
      Result:= UnsignedFloat;
    end else
    if P^ = OpenSub then
    begin
      Inc(P);
      Result:= Expression;
      if P^ = CloseSub then
        inc(P)
      else
        raise EExpression.Create(' ) expected')
    end else
    if P^ in PrimaryIdentChars then
    begin
      case GetTok(Identifier, Operator, BoolLit) of
        ttOperator:
        if Operator = opNot then
        begin
          inc(P);
          Result:= TUnaryOp.Create(opNot, Factor)
        end else
        begin
          raise EExpression.CreateFmt('%s not allowed here', [NOperator[Operator]]);
        end;
        ttIdentifier:
        begin
          PList:= nil;
          try
            SwallowWhitespace;
            MoreParameters:= P^ = OpenSub;
            if MoreParameters then
            begin
              PList:= TParameterList.Create;
              while MoreParameters do
              begin
                inc(P);
                PList.Add(Expression);
                MoreParameters:= P^ = ','
              end;
              {bug fix 11/11/97}
              if P^ = CloseSub then
                Inc(P)
              else
                raise EExpression.Create('Incorrectly formed parameters')
            end;
            Result:= StandardFunctions(Identifier, PList);
            if (Result = nil) and Assigned(IdentifierFunction) then
              Result:= IdentifierFunction(Identifier, PList);
            if Result = nil then
              raise EExpression.CreateFmt('Unknown Identifier %s', [Identifier]);
          finally
            if Result = nil then
              PList.Free
          end
        end;
        ttBooleanLiteral:
        begin
          Result:= TBooleanLiteral.Create(BoolLit)
        end
      end;
    end else
    if EoE then
    begin
      raise EExpression.Create('Unexpected end of factor')
    end else
    begin
      raise EExpression.Create('Syntax error') {leak here ?}
    end
  except
    Result.Free;
    raise
  end
end;  {factor}

function Term: TExpression;
var
  Identifier: String;
  Operator: TOperator;
  BoolLit: Boolean;
  SavedP: PChar;

begin {term}
  Result:= Factor;
  try
    SwallowWhitespace;
    if EoE then
    begin
    end else
    if (P^ = '*') then
    begin
      inc(P);
      Result:= TBinaryOp.Create(opMult, Result, Term)
    end else
    if (P^ = '/') then
    begin
      inc(P);
      Result:= TBinaryOp.Create(opDivide, Result, Term);
    end else
    if P^ in OpChars then  {only checks for single char operators}
    begin
    end else
    if P^ in PrimaryIdentChars then
    begin
      SavedP:= P;
      case GetTok(Identifier, Operator, BoolLit) of
        ttIdentifier:
        begin
          raise EExpression.CreateFmt('Identifier %s not allowed here', [Identifier]);
        end;
        ttOperator:
        if Operator in [opAnd, opDiv, opMod, opShl, opShr] then
        begin
          Result:= TBinaryOp.Create(Operator, Result, Term);
        end else
        begin
          P:= SavedP; {push token back - not ours}
        end;
        ttBooleanLiteral:
        begin
          raise EExpression.Create('Boolean literal not allowed here')
        end
      end
    end else
    begin
      raise EExpression.CreateFmt('char %s in input stream', [P^]);
    end
  except
    Result.Free;
    raise
  end
end;  {term}

function Simple: TExpression;
var
  Identifier: String;
  Operator: TOperator;
  BoolLit: Boolean;
  SavedP: PChar;
begin {simple}
  Result:= Term;
  try
    SwallowWhitespace;
    if EoE then
    begin  {finished}
    end else
    if (P^ = '+') then
    begin
      inc(P);
      Result:= TBinaryOp.Create(opPlus, Result, Simple)
    end else
    if (P^ = '-') then
    begin
      inc(P);
      Result:= TBinaryOp.Create(opMinus, Result, Simple)
    end else
    if P^ in OpChars then  {only checks for single char operators}
    begin    {finished}
    end else
    begin
      SavedP:= P;
      case GetTok(Identifier, Operator, BoolLit) of
        ttIdentifier:
        begin
          raise EExpression.CreateFmt('Identifier %s not allowed here', [Identifier])
        end;
        ttOperator:
        if (Operator = opOr) or (Operator = opXor) then
          Result:= TBinaryOp.Create(Operator, Result, Term)
        else
        begin
          P:= SavedP  {push token back - not ours}
        end;
        ttBooleanLiteral:
        begin
          raise EExpression.Create('Boolean literal not allowed here')
        end
      end
    end
  except
    Result.Free;
    raise
  end
end;  {simple}

var
  OpString: String;
  Op: TOperator;
  OpFound: Boolean;
  Finished: Boolean;
begin {expression}
  Result:= nil;
  try
    Finished:= false;
    repeat
      SwallowWhitespace;
      if not EoE then
      begin
        Result:= Simple;
        if P^ in RelationalChars then
        begin
          OpString:= P^;
          inc(P);
          if P^ in RelationalChars then
          begin
            OpString:= OpString + P^;
            inc(P)
          end;
          OpFound:= false;
          for Op:= opEQ to opGTE do
          if OpTokens[Op] = OpString then
          begin
            OpFound:= true;
            break
          end;
          if not OpFound then
            raise EExpression.CreateFmt('%s not a valid operator', [OpString])
          else
            Result:= TRelationalOp.Create(Op, Result, Simple)
        end
      end else
      begin
        Finished:= true
      end
    until Finished
  except
    Result.Free;
    raise
  end
end;  {expression}

begin
  P:= PChar(S);
  Result:= Expression
{bug - P^ may equal ')' at this stage... &&&}
end;

end.

{
18/6/97
loosely based on syntax diagrams in BP7 Language Guide pages 66 to 79.
This is where the nomenclature Term, Factor, SimpleExpression, Expression is
derived.

written for Mark Page's troxler thing - as part of the report definition language,
but might be needed for Robot application framework. Not tested much.


7/9/97
function handling completely changed.

added support for Integers including support for the following operators
  bitwise not
  bitwise and
  bitwise or
  bitwise xor
  shl
  shr
  div

now support std functions:

arithmetic...
  TRUNC, ROUND, ABS, ARCTAN, COS, EXP, FRAC, INT,
     LN, PI, SIN, SQR, SQRT, POWER

string...
  UPPER, LOWER, COPY, POS, LENGTH

Fixed a couple of minor bugs. Forgotten what they are.

16/9/97
realised (whilst lying in the bath) that the way this unit
handles parameters is a bit daft. It should be possible to
pass the parameter stack to the identifier function. The only
problem with this approach is how to handle disposal of the stack.

We could require that the identifier function disposes of the stack...
I don't really like this (I can't think why at the moment). Another
approach would be to define a 'placeholder' expression which does nothing
but hold the parameter list and the <clients> expression.

Compromise solution:
  The parser constructs an instance of TParameter list and passes it to
  the 'user' via a call to IdentifierFunction. There are four possible
  mechanisms for disposal of the parameter list.
     a) If the Identifier function returns NIL the parser disposes
        of the parameter list then raises 'Unknown identifier'.
     b) If the Identifier function raises an exception then the parser
        catches this exception (in a 'finally' clause) and disposes
        of the parameter list.
     c) If the Identifier function returns an expression then it must
        dispose of the parameter list if it does not wish to keep it.
     d) If the Identifier function returns an expression which is
        derived from TFunction, then it may pass the parameter list to
        its result. The result frees the parameter list when it is freed.
        (i.e. ParameterList passed to TFunction.Create is freed by
        TFunction.Destroy)


Simple rule - if IdentFunction returns Non-nil then parameters are
responsiblity of the object returned. Otherwise caller will handle. OK?

5/11/97
First issue of Troxler.exe

11/11/97
Bug caused mishandling of function lists. Fixed.

30/12/97
Some slight restructing. Added more comprehensive documentation. Removed
a few calls to StrPas which are redundant under D2/D3


General Comments/Notes
----------------------

String is superset of Float is superset of Integer is Superset of Boolean
this is not quite like pascal...

String - Float - Integer - Boolean
<-upcast                 downcast->

Boolean can always be read as Integer (True = 1 false = 0)
But integer can never be read as Boolean.

Float can always be read as String but string can NEVER be read as Float -
even if string forms valid Float.

Often explicit casts are not required

Enforcement of type compatibility is a great deal less strict than Pascal.

If an operator requires a particular type of operand then both operands
are upcast to the nearest compatible type.

I have arbitrarily asserted that both parties to a relational operator must
be of identical (not compatible) type. This may be a bad decision and
perhaps implicit Upcasts (like that above) should be allowed. Not difficult
to do... Can always use specific upcast. I think a downcast always fails.

Client defined identifiers sort of supported.
}